Sometimes, masked expressions can simply be constructed as strings
One example are formulas (e.g. in lm(y ~ x1 + x2))
The as.formula function can create formula objects manually
linreg <-function(df, y, x) { fm <-paste(y, "~", paste(x, collapse =" + ")) fm <-as.formula(fm)lm(fm, data = df)}linreg(ess, y ="trust_eu", x =c("age", "left_right"))
2.4 Strategy 3: Change names
In case of poorly implemented data masking, no tools are available to inject variables
One strategy to overcome such situations could be to simply change the object names
Render the leaflet map once. Note that the render function does not take any dependencies and is thus only run once.
2
Add a marker every time the map is clicked somewhere. Note that the marker is added not to a new map, but to a proxy of the map that is already rendered.
3
Remove a marker that is clicked. Note how the observer is only triggered when a marker is clicked, i.e. when input$map_marker_click is triggered.
8 Exercise session
8.1 Plotly
Exercise 1.1
Add a new tab to the app. Add an output canvas to the UI and a render function to the server function such that the new tab is able to display an interactive plotly widget.
Solution 1.2
In the UI, add a new tabPanel() to the tabsetPanel().
In the server function, add renderPlotly and assign it to the output object.
output$hist <-renderPlotly({})
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### New tab ----tabPanel(title ="Histogram",plotlyOutput("hist", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) }) output$hist <-renderPlotly({ })}shinyApp(ui = ui, server = server)
Exercise 1.2
In section 3, we implemented a bivariate plot of the ESS data. For this exercise, create a univariate plotly plot of one of the trust variables. In the solution, I will be using a histogram, but this could also be a stacked bar chart, a kernel density curve, etc. The idea is to get a quick overview of the statistical distribution of a trust variable.
You can do this either through plotly’s own grammar (plot_ly()) or by converting a ggplot (ggplotly()). In the solutions, I will be using plotly though.
Note that, due to a bug in plotly, the labels of the ESS dataset have to be removed from the dataset. This can be done either by casting as.numeric on a variable or by zapping labels with haven::zap_labels().
Solution 1.2
The following solution implements a histogram of the trust_parliament variable.
ess <-readRDS("data/ess_trust.rds")plot_ly(ess, x =~as.numeric(trust_parliament)) %>%add_histogram()
Exercise 1.3
Customize the plotly plot according to the following requests:
Change the axis titles to something useful
Decrease the opacity to 70%
Remove the modebar
Increase the gap between histogram bars to 20%.
Change the bar color to green
Tip
Recall that plotly can be customized using the layout, style, and config functions.
To find out about options specific to a plotly histogram, call plotly::schema() and navigate to traces -> histogram.
Plotly can be very confusing and there is no shame in using google!
Solution 1.3
plot_ly(ess) %>%add_histogram(x =~as.numeric(trust_parliament)) %>%# everything that changes the overall theming goes herelayout(xaxis =list(title ="Trust in the national parliament"),yaxis =list(title ="Observations"),bargap =0.2 ) %>%# everything that changes the data- and plot-specific theming goes herestyle(opacity =0.7, marker =list(color ="green")) %>%# everything that changes the interactivity goes hereconfig(displayModeBar =FALSE)
Exercise 1.4
Implement the plot from exercise 1.3 in the Shiny app. Instead of plotting a single static variable, link the histogram to the input selector for the dependent variable (input$xvar) such that choosing a different trust variable updates the histogram.
Solution 1.4
output$hist <-renderPlotly({plot_ly(filtered()) %>%add_histogram(x =as.numeric(ess[input$xvar])) %>%# everything that changes the overall theming goes herelayout(xaxis =list(title ="Trust in the national parliament"),yaxis =list(title ="Observations"),bargap =0.2 ) %>%# everything that changes the data- and plot-specific theming goes herestyle(opacity =0.7, marker =list(color ="green")) %>%# everything that changes the interactivity goes hereconfig(displayModeBar =FALSE)})
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### New tab ----tabPanel(title ="Histogram",plotlyOutput("hist", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) }) output$hist <-renderPlotly({plot_ly(filtered()) %>%add_histogram(x =as.numeric(ess[[input$xvar]])) %>%# everything that changes the overall theming goes herelayout(xaxis =list(title = input$xvar),yaxis =list(title ="Observations"),bargap =0.2 ) %>%# everything that changes the data- and plot-specific theming goes herestyle(opacity =0.7, marker =list(color ="green")) %>%# everything that changes the interactivity goes hereconfig(displayModeBar =FALSE) })}shinyApp(ui = ui, server = server)
8.2 Leaflet
Exercise 2.1
Add a new tab to the app. Add an output canvas to the UI and a render function to the server function such that the new tab is able to display an interactive leaflet widget.
Solution 2.1
In the UI, add a new tabPanel() to the tabsetPanel().
In the server function, add renderLeaflet and assign it to the output object.
output$hist <-renderLeaflet({})
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### New tab ----tabPanel(title ="Histogram",leafletOutput("hist", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) }) output$hist <-renderLeaflet({ })}shinyApp(ui = ui, server = server)
Exercise 2.2
In section 4, we added an interactive map showing the average of the ESS dataset across Europe. For this exercise, create an interactive map that maps one of the trust variables using a binned scale. Add a basemap, polygons, a legend, and set the default view on Southeastern Europe.
Solution 2.2
colorBin creates a binned palette function to use in Leaflet. The domain argument must be passed, else the legend will be empty
addTiles adds an OpenStreetMap basemap
setView zooms in to a specific location
addPolygons adds polygon data to the map
The fillColor argument takes a vector of colors which can be created using the pal palette function
In section 4, we added labels that appear when hovering over a polygon. In this exercise, add labels that appear when clicking on the GESIS marker from the last exercise. The label should read “This is GESIS in Mannheim, DE” (incl. formatting).
Implement the leafelt map from exercise 2.2 to 2.4 in the Shiny app. Instead of plotting a single static variable, link the histogram to the input selector for the dependent variable (input$xvar) such that choosing a different trust variable updates the histogram.
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### New tab ----tabPanel(title ="GESIS map",leafletOutput("gmap", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) })# plot gesis map output$gmap <-renderLeaflet({ xvar <- input$xvar pal <-colorBin("YlOrRd", domain = ess_geo[[xvar]]) popup <-HTML("This is <strong>GESIS</strong> in Mannheim, DE")leaflet(ess_geo) %>%addProviderTiles("Stadia.StamenTerrain") %>%setView(13, 45, 5) %>%addPolygons(fillColor =pal(ess_geo[[xvar]]),color ="black",opacity =1,weight =1,fillOpacity =0.6 ) %>%addLegend(pal = pal,values = ess_geo[[xvar]],position ="bottomright",opacity =1 ) %>%addCircleMarkers(lng =8.46,lat =49.48,color ="blue",fillOpacity =1,opacity =1,radius =3,popup = popup ) })}shinyApp(ui = ui, server = server)
8.3 Plot events
8.4 Beyond plotly and leaflet
Exercise 4.1
Thinking back to the list of Javascript libraries for interactive plotting in section 2.1, pick one R interface that appeals to you the most. Study its documentation and vignettes to get a basic understanding of the interface.
Exercise 4.2
Add a new tab to the app. Replicate the violin plots from section 3 as boxplots using an R interface of your choice.
Note that not all plotting libraries support violin and boxplots to the same degree.
Example solution 4.2
An example solution with the highcharter package:
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### Highcharts tab ----tabPanel(title ="Highcharts",highchartOutput("highcharts", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) })# render highcharts output$highcharts <-renderHighchart({ xvar <- input$xvar yvar <- input$yvar ess <-filtered() %>%zap_labels() %>%na.omit() %>%select(all_of(c(xvar, yvar))) %>%setNames(c("x", "y"))highchart() %>%hc_add_series_list(data_to_boxplot( ess, x, y,color ="black",fillColor ="#ADD8E6",showInLegend =FALSE,name = xvar )) %>%hc_yAxis(min =0, max =max(ess$y, na.rm =TRUE),title =list(text = yvar) ) %>%hc_xAxis(type ="category", title =list(text = xvar)) %>%hc_legend(enabled =FALSE) })}shinyApp(ui = ui, server = server)
An example solution with the apexcharter package:
Complete code (important lines are highlighted)
library(dplyr)library(tidyr)library(shiny)library(plotly)library(leaflet)library(haven)ess <-readRDS("data/ess_trust.rds")ess_geo <-readRDS("data/ess_trust_geo.rds")# UI ----ui <-fluidPage(titlePanel("European Social Survey - round 10"),## Sidebar ----sidebarLayout(sidebarPanel(### select dependent variableselectInput("xvar",label ="Select a dependent variable",choices =c("Trust in country's parliament"="trust_parliament","Trust in the legal system"="trust_legal","Trust in the police"="trust_police","Trust in politicians"="trust_politicians","Trust in political parties"="trust_parties","Trust in the European Parliament"="trust_eu","Trust in the United Nations"="trust_un" ) ),### select a variable ----selectInput("yvar",label ="Select an independent variable",choices =c("Placement on the left-right scale"="left_right","Age"="age","Feeling about household's income"="income_feeling","How often do you use the internet?"="internet_use","How happy are you?"="happiness" ) ),### select a country ----selectizeInput("countries",label ="Filter by country",choices =unique(ess$country),selected ="FR",multiple =TRUE ),### filter values ----sliderInput("range",label ="Set a value range",min =min(ess$trust_parliament, na.rm =TRUE),max =max(ess$trust_parliament, na.rm =TRUE),value =range(ess$trust_parliament, na.rm =TRUE),step =1 ) ),## Main panel ----mainPanel(tabsetPanel(type ="tabs",### Table tab ----tabPanel(title ="Table",div(style ="height: 600px; overflow-y: auto;",tableOutput("table") ) ),### Plot tab ----tabPanel(title ="Plot",plotlyOutput("plot", height =600) ),### Map tab ----tabPanel(title ="Map",leafletOutput("map", height =600) ),### Highcharts tab ----tabPanel(title ="Highcharts",apexchartOutput("highcharts", height =600) ) ) ) ))# Server ----server <-function(input, output, session) {# update slider ----observe({ var <-na.omit(ess[[input$xvar]]) is_ordered <-is.ordered(var) var <-as.numeric(var)updateSliderInput(inputId ="range",min =min(var),max =max(var),value =range(var),step =if (is_ordered) 1 ) }) %>%bindEvent(input$xvar)# filter data ---- filtered <-reactive({req(input$countries, cancelOutput =TRUE) xvar <- input$xvar yvar <- input$yvar range <- input$range# select country ess <- ess[ess$country %in% input$countries, ]# select variable ess <- ess[c("idno", "country", xvar, yvar)]# apply range ess <- ess[ess[[xvar]] > range[1] & ess[[xvar]] < range[2], ] ess })# render table ---- output$table <-renderTable({filtered() }, height =400)# render plot ---- output$plot <-renderPlotly({ xvar <- input$xvar yvar <- input$yvar plot_data <-filtered() %>%drop_na() %>%mutate(across(where(is.numeric), .fns = as.ordered)) p <-ggplot(plot_data) +aes(x = .data[[xvar]], y = .data[[yvar]], group = .data[[xvar]]) +geom_violin(fill ="lightblue", show.legend =FALSE) +theme_classic()ggplotly(p) })# render map ---- output$map <-renderLeaflet({ var <- input$xvar ess_geo <- ess_geo[c("country", var)]# create labels with a bold title and a body labels <-sprintf("<strong>%s</strong><br>%s", ess_geo$country, ess_geo[[var]] ) labels <-lapply(labels, HTML)# create a palette for numerics and ordinalsif (is.ordered(ess_geo[[var]])) { pal <-colorFactor("YlOrRd", domain =NULL) } else { pal <-colorNumeric("YlOrRd", domain =NULL) }# construct leaflet canvasleaflet(ess_geo) %>%# add base mapaddTiles() %>%# add choroplethsaddPolygons(fillColor =pal(ess_geo[[var]]),weight =2,opacity =1,color ="white",fillOpacity =0.7,# highlight polygons on hoverhighlightOptions =highlightOptions(weight =2,color ="#666",fillOpacity =0.7,bringToFront =TRUE ),label = labels ) %>%# add a legendaddLegend(position ="bottomleft",pal = pal,values = ess_geo[[var]],opacity =0.7,title = var ) })# render highcharts output$highcharts <-renderApexchart({ xvar <- input$xvar yvar <- input$yvarapex(filtered(), aes(.data[["trust_eu"]], .data[["left_right"]]), "boxplot") %>%ax_plotOptions(boxPlot =boxplot_opts(color.upper ="#ADD8E6", color.lower ="#ADD8E6")) %>%ax_stroke(colors =list("black")) %>%ax_labs(x ="eu_trust", y ="left_right") })}shinyApp(ui = ui, server = server)